perm filename LCPCRS.PAS[PAS,SYS]1 blob
sn#329922 filedate 1978-09-07 generic text, type T, neo UTF8
00100 PROGRAM CROSS;
00200 %$L-,C-\
00300 (*PROGRAM WHICH CREATES A CROSS REFERENCE LISTING WITH SIMULTANEOUS
00400 FORMATTING OF A PASCAL PROGRAM. WRITTEN BY MANUEL MALL.
00500 THE FOLLOWING CHANGES WERE MADE HERE BY LARRY PAULSON:
00600 ! I. SPEED-UPS
00700 ! A. NO LINE NUMBERS ARE PUT ON THE 'NEW' FILE.
00800 ! B. THE /F SWITCH SUPPRESSES THE LISTING OF THE SOURCE FILE.
00900 ! THE CROSS-REFERENCE APPEARS AS FILE '<NAME>.CRL'.
01000 !
01100 ! II. SYNTAX CHANGES
01200 ! A. SOURCE FILES WITH NO MAIN PROGRAM (THE $M- SWITCH) DO NOT CAUSE
01300 ! ERROR MESSAGES. '(NO MAIN PROGRAM)' IS PRINTED ON THE TERMINAL.
01400 ! CROSS DOES NOT NOTICE IF THE SWITCH IS ACTUALLY PRESENT.
01500 !
01600 ! III. CHANGES TO THE CROSS-REFERENCE LISTING
01700 ! A. NO PAGE NUMBERS ARE PRINTED IN THE LISTING IF NO SOS PAGE MARKS
01800 ! WERE USED.
01900 ! B. IF AN IDENTIFIER IS REFERENCED MORE THAN ONCE ON THE SAME LINE,
02000 ! THE LINE IS STILL MENTIONED ONLY ONCE.
02100 !
02200 ! IV. GENERAL
02300 ! A. IF NO OUTPUTFILE IS GIVEN, '<NAME>.NEW' IS ASSUMED.
02400 ! IF NO INPUTFILE IS GIVEN, IT IS TAKEN TO BE THE SAME AS THE OUTPUTFILE.
02500 ! B. THE INDENTATION CONSTANT MAY BE SET BY '/INDENT:<INTEGER>', WHICH
02600 ! MAY BE ABBREVIATED '/I<INTEGER>', E.G. '/I3'. DEFAULT IS 4.
02700 ! C. '←' MAY BE USED FOR '=' IN THE INPUT LINE. *)
02800 CONST
02900 VERSION = 'CROSS VERSION OF APRIL 15, 1977';
03000 MAXCH = 114; %MAXIMUM NUMBER OF CHARS PER PRINT LINE\
03100 MAXLINE = 57; %MAXIMAL NUMBER OF LINES PER PRINT PAGE\
03200 HT = 11B; %ASCII HORIZONTAL TAB\
03300 LF = 12B; %ASCII LINE FEED\
03400 FF = 14B; %ASCII FORM FEED\
03500 CR = 15B; %ASCII CARIAGE RETURN\
03600
03700 TYPE
03800 ERRKINDS = (ERRINBLKSTR,MISSGENDUNTIL,MISSGTHEN,MISSGOF,MISSGEXIT,MISSGRPAR,MISSGQUOTE);
03900 ROUTINFO = (NOTROUT, PROC, FUNC);
04000 LINEPTRTY = ↑LINE;
04100 LISTPTRTY = ↑LIST;
04200 PROCCALLTY = ↑PROCCALL;
04300 PROCSTRUCTY = ↑PROCSTRUC;
04400 LINENRTY = 0..17777B; %MEANS MAX LINE COUNT IS 8000\
04500 PAGENRTY = 0..37B; %AND.. MAX PAGE COUNT IS 32\
04600 WORD = PACKED ARRAY [1..10] OF CHAR;
04700 SYMBOL = (LABELSY,CONSTSY,TYPESY,VARSY, %DECSYM\
04800 FUNCTIONSY,PROCEDURESY,INITPROCSY, %PROSYM\
04900 ENDSY,UNTILSY,ELSESY,THENSY,EXITSY,OFSY,DOSY,EOBSY, %ENDSYMBOLS\
05000 BEGINSY,CASESY,LOOPSY,REPEATSY,IFSY, %BEGSYM\
05100 RECORDSY,FORWARDSY,GOTOSY,OTHERSY,INTCONST,IDENT,STRGCONST,EXTERNSY,LANGSY,
05200 RPARENT,SEMICOLON,POINT,LPARENT,COLON,LBRACK,OTHERSSY%DELIMITER\);
05300
05400 LINE = PACKED RECORD
05500 %DESCRIPTION THE LINE NUMBER\
05600 LINENR : LINENRTY; %LINE NUMBER\
05700 PAGENR : PAGENRTY; %PAGE NUMBER\
05800 CONTLINK : LINEPTRTY %NEXT LINE NUMBER RECORD\
05900 END;
06000
06100 LIST = PACKED RECORD
06200 %DESCRIPTION OF IDENTIFIERS\
06300 NAME : WORD; %NAME OF THE IDENTIFIER\
06400 LLINK , %LEFT SUCCESSOR IN TREE\
06500 RLINK : LISTPTRTY; %RIGHT SUCCESSOR IN TREE\
06600 FIRST , %POINTER TO FIRST LINE NUMBER RECORD\
06700 LAST : LINEPTRTY; %POINTER TO LAST LINE NUMBER RECORD\
06800 PROCVAR : ROUTINFO;
06900 CALLED, %POINTS TO THE FIRST PROCEDURE CALLED BY THIS ONE\
07000 CALLEDBY : PROCCALLTY %POINTER TO FIRST CALLING PROCEDURE\
07100 END;
07200
07300 PROCCALL = PACKED RECORD
07400 %DESCRIPTION OF PROCEDURE CALLS\
07500 PROCNAME : LISTPTRTY; %POINTER TO THE APPROPRIATE IDENTIFIER RECORD\
07600 NEXTPROC : PROCCALLTY; %POINTER TO THE NEXT PROCEDURE\
07700 FIRST, %LINE NUMBER RECORD FOR THE FIRST CALL\
07800 LAST : LINEPTRTY %LINE NUMBER RECORD FOR THE LAST CALL\
07900 END;
08000
08100 DBLEDECLIST = ↑DOUBLEDEC;
08200 DOUBLEDEC = PACKED RECORD
08300 %PROCEDURES WHICH ARE ALSO DEFINED AS NORMAL IDENTIFIERS\
08400 PROCORT : LISTPTRTY; %POINTER TO THE PROCEDURE\
08500 NEXTPROC: DBLEDECLIST %NEXT DOUBLY DECLARED PROCEDURE\
08600 END;
08700
08800 PROCSTRUC = PACKED RECORD
08900 %DESCRIPTION OF THE PROCEDURE NESTING\
09000 PROCNAME : LISTPTRTY; %POINTER TO THE APPROPRIATE IDENTIFIER\
09100 NEXTPROC : PROCSTRUCTY; %POINTER TO THE NEXT ELEMENT\
09200 LINENR : LINENRTY; %LINE NUMBER OF THE PROCEDURE DEFINITION\
09300 PAGENR , %PAGE NUMBER OF THE PROCEDURE DEFINITION\
09400 PROCLEVEL: PAGENRTY %NESTING DEPTH OF THE PROCEDURE\
09500 END;
09600
09700 VAR
09800 FEED, %INDENTATION BY PROCEDURES AND BLOCKS\
09900 I, %INDEX VARIABLE\
10000 BUFFLEN, %LENGTH OF THE CURRENT LINE IN THE INPUT BUFFER\
10100 BUFFMARK, %LENGTH OF THE ALREADY PRINTED PART OF THE BUFFER\
10200 BUFFERPTR, %POINTER TO THE NEXT CHARACTER IN THE BUFFER\
10300 BUFFINDEX, %CHARACTER COUNTER FOR BUFF\
10400 BMARKNR, %NUMBER FOR MARKING OF 'BEGIN', 'LOOP' ETC.\
10500 EMARKNR, %NUMBER FOR MARKING OF 'END', 'UNTIL' ETC.\
10600 SPACES, %INDENTATION FOR THE FORMATTING\
10700 LASTSPACES, %ONE-TIME OVERRIDING VALUE FOR SPACES\
10800 SYLENG, %LENGTH OF THE LAST READ IDENTIFIER OR LABEL\
10900 LEVEL, %NESTING DEPTH OF THE CURRENT PROCEDURE\
11000 BLOCKNR, %COUNTS THE STATEMENTS 'BEGIN', 'CASE', 'LOOP', 'REPEAT', 'IF'\
11100 PAGECNT, %COUNTS THE SOS-PAGES\
11200 PAGECNT2, %COUNTS THE PRINT PAGES PER SOS-PAGE\
11300 INCREMENT, %PARAMETER FOR THE INCREMENTING OF THE LINE NUMBER\
11400 MAXINC, %GREATEST ALLOWABLE LINE NUMBER\
11500 REALLINCNT, %COUNTS THE LINES PER PRINT PAGE\
11600 LINECNT : INTEGER; %COUNTS THE LINES PER SOS-PAGE\
11700 PROCDEC: ROUTINFO;
11800 INPUTFILE, %DESCRIPTION OF THE INPUT FILE\
11900 OUTPUTFILE : RECORD
12000 %DESCRIPTION OF THE OUTPUT FILE\
12100 FILENAME : PACKED ARRAY [1..9] OF CHAR;
12200 DEVICE : PACKED ARRAY [1..6] OF CHAR;
12300 PPN : INTEGER;
12400 PROT : 0..777B
12500 END;
12600 PROCSTRUCDATA : RECORD
12700 %NEXT PROCEDURE TO BE PUT IN NESTING LIST\
12800 CASE EXISTS : BOOLEAN OF
12900 TRUE : (ITEM : PROCSTRUC)
13000 END;
13100 BUFFER : ARRAY [-1..148] OF CHAR; %INPUT BUFFER (147 CHARACTERS = MAX. LENGTH SOS-LINE)\
13200 %BUFFER HAS 2 EXTRA POSITIONS ON THE LEFT AND ONE ON THE RIGHT\
13300 LINENB : PACKED ARRAY [1..5] OF CHAR; %SOS-LINE NUMBER\
13400 TIMEANDDAY : PACKED ARRAY [1..24] OF CHAR; %HEADING DATE AND TIME\
13500 SY : WORD; %LAST SYMBOL READ\
13600 SYTY : SYMBOL; %TYPE OF THE LAST SYMBOL READ\
13700 FAST, %IF TRUE, MAKE NO LISTING FILE\
13800 SEQUENCE, %IF TRUE, LINE NUMBERS ARE OUTPUT TO 'NEW' FILE\
13900 THENDO, %SET WHENEVER 'SPACES := SPACES+DOFEED' IS EXECUTED\
14000 FWDDECL, %SET TRUE BY BLOCK AFTER 'FORWARD', 'EXTERN'\
14100 ERRFLAG, %SET IF AN ERROR IS DETECTED\
14200 OLDSPACES, %SET WHEN LASTSPACES SHOULD BE USED\
14300 EOLINE, %SET AT END ON INPUT LINE\
14400 GOTOINLINE, %SET IF A HORRENDOUS GOTO STATEMENT IN THIS LINE\
14500 EOB : BOOLEAN; %EOF-FLAG\
14600 CH, %LAST READ CHARACTER\
14700 BMARKTEXT, %CHARACTER FOR MARKING OF 'BEGIN' ETC.\
14800 EMARKTEXT: CHAR; %CHARACTER FOR MARKING OF 'END' ETC.\
14900 DELSY : ARRAY [' '..'←'] OF SYMBOL; %TYPE ARRAY FOR DELIMITER CHARACTERS\
15000 RESNUM : ARRAY ['A'..'['] OF INTEGER; %INDEX OF THE FIRST KEYWORD BEGINNING WITH THE INDEXED LETTER\
15100 RESLIST : ARRAY [1..46] OF WORD; %LIST OF THE RESERVED WORDS\
15200 RESSY : ARRAY [1..46] OF SYMBOL; %TYPE ARRAY OF THE RESERVED WORDS\
15300 ALPHANUM, %CHARACTERS FROM 0..9 AND A..Z\
15400 DIGITS, %CHARACTERS FROM 0..9\
15500 LETTERS : SET OF CHAR; %CHARACTERS FROM A..Z\
15600 RELEVANTSYM, %START SYMBOLS FOR STATEMENTS AND PROCEDURES\
15700 PROSYM, %ALL SYMBOLS WHICH BEGIN A PROCEDURE\
15800 DECSYM, %ALL SYMBOLS WHICH BEGIN DECLARATIONS\
15900 BEGSYM, %ALL SYMBOLS WHICH BEGIN COMPOUND STATEMENTS\
16000 ENDSYM : SET OF SYMBOL; %ALL SYMBOLS WHICH TERMINATE STATEMENTS OR PROCEDURES\
16100 LISTPTR : LISTPTRTY; %POINTER INTO THE BINARY TREE OF THE IDENTIFIER\
16200 FIRSTNAME : ARRAY ['A'..'Z'] OF LISTPTRTY; %POINTER TO THE ROOTS OF THE TREE\
16300 PROCSTRUCF, %POINTER TO THE FIRST ELEMENT OF THE PROCEDURE CALLS LIST\
16400 PROCSTRUCL : PROCSTRUCTY; %POINTER TO THE LAST ELEMENT OF THE PROCEDURE CALLS LIST\
16500 NEWFIL : TEXT; %OUTPUT FILE ONTO WHICH THE 'NEW' FILE IS WRITTEN\
16600 MESSAGE : PACKED ARRAY [1..23] OF CHAR; %COMPLETION MESSAGE\
16700
16800 INITPROCEDURE;
16900 BEGIN
17000 RESNUM['A'] := 1;
17100 RESNUM['B'] := 4;
17200 RESNUM['C'] := 6;
17300 RESNUM['D'] := 10;
17400 RESNUM['E'] := 13;
17500 RESNUM['F'] := 17;
17600 RESNUM['G'] := 22;
17700 RESNUM['H'] := 23;
17800 RESNUM['I'] := 23;
17900 RESNUM['J'] := 27;
18000 RESNUM['K'] := 27;
18100 RESNUM['L'] := 27;
18200 RESNUM['M'] := 29;
18300 RESNUM['N'] := 29;
18400 RESNUM['O'] := 31;
18500 RESNUM['P'] := 34;
18600 RESNUM['Q'] := 36;
18700 RESNUM['R'] := 36;
18800 RESNUM['S'] := 39;
18900 RESNUM['T'] := 40;
19000 RESNUM['U'] := 43;
19100 RESNUM['V'] := 44;
19200 RESNUM['W'] := 45;
19300 RESNUM['X'] := 47;
19400 RESNUM['Y'] := 47;
19500 RESNUM['Z'] := 47;
19600 RESNUM['['] := 47;
19700 RESLIST[ 1] :='ALGOL '; RESSY [ 1] := LANGSY;
19800 RESLIST[ 2] :='AND '; RESSY [ 2] := OTHERSY;
19900 RESLIST[ 3] :='ARRAY '; RESSY [ 3] := OTHERSY;
20000 RESLIST[ 4] :='BEGIN '; RESSY [ 4] := BEGINSY;
20100 RESLIST[ 5] :='BOOLEAN '; RESSY [ 5] := OTHERSY;
20200 RESLIST[ 6] :='CHAR '; RESSY [ 6] := OTHERSY;
20300 RESLIST[ 7] :='CASE '; RESSY [ 7] := CASESY;
20400 RESLIST[ 8] :='CONST '; RESSY [ 8] := CONSTSY;
20500 RESLIST[ 9] :='COBOL '; RESSY [ 9] := LANGSY;
20600 RESLIST[10] :='DO '; RESSY [10] := DOSY;
20700 RESLIST[11] :='DIV '; RESSY [11] := OTHERSY;
20800 RESLIST[12] :='DOWNTO '; RESSY [12] := OTHERSY;
20900 RESLIST[13] :='END '; RESSY [13] := ENDSY;
21000 RESLIST[14] :='ELSE '; RESSY [14] := ELSESY;
21100 RESLIST[15] :='EXIT '; RESSY [15] := EXITSY;
21200 RESLIST[16] :='EXTERN '; RESSY [16] := EXTERNSY;
21300 RESLIST[17] :='FOR '; RESSY [17] := OTHERSY;
21400 RESLIST[18] :='FILE '; RESSY [18] := OTHERSY;
21500 RESLIST[19] :='FORWARD '; RESSY [19] := FORWARDSY;
21600 RESLIST[20] :='FUNCTION '; RESSY [20] := FUNCTIONSY;
21700 RESLIST[21] :='FORTRAN '; RESSY [21] := LANGSY;
21800 RESLIST[22] :='GOTO '; RESSY [22] := GOTOSY;
21900 RESLIST[23] :='IF '; RESSY [23] := IFSY;
22000 RESLIST[24] :='IN '; RESSY [24] := OTHERSY;
22100 RESLIST[25] :='INTEGER '; RESSY [25] := OTHERSY;
22200 RESLIST[26] :='INITPROCED'; RESSY [26] := INITPROCSY;
22300 RESLIST[27] :='LOOP '; RESSY [27] := LOOPSY;
22400 RESLIST[28] :='LABEL '; RESSY [28] := LABELSY;
22500 RESLIST[29] :='NOT '; RESSY [29] := OTHERSY;
22600 RESLIST[30] :='NIL '; RESSY [30] := OTHERSY;
22700 RESLIST[31] :='OR '; RESSY [31] := OTHERSY;
22800 RESLIST[32] :='OF '; RESSY [32] := OFSY;
22900 RESLIST[33] :='OTHERS '; RESSY [33] := OTHERSSY;
23000 RESLIST[34] :='PACKED '; RESSY [34] := OTHERSY;
23100 RESLIST[35] :='PROCEDURE '; RESSY [35] := PROCEDURESY;
23200 RESLIST[36] :='REAL '; RESSY [36] := OTHERSY;
23300 RESLIST[37] :='RECORD '; RESSY [37] := RECORDSY;
23400 RESLIST[38] :='REPEAT '; RESSY [38] := REPEATSY;
23500 RESLIST[39] :='SET '; RESSY [39] := OTHERSY;
23600 RESLIST[40] :='THEN '; RESSY [40] := THENSY;
23700 RESLIST[41] :='TO '; RESSY [41] := OTHERSY;
23800 RESLIST[42] :='TYPE '; RESSY [42] := TYPESY;
23900 RESLIST[43] :='UNTIL '; RESSY [43] := UNTILSY;
24000 RESLIST[44] :='VAR '; RESSY [44] := VARSY;
24100 RESLIST[45] :='WHILE '; RESSY [45] := OTHERSY;
24200 RESLIST[46] :='WITH '; RESSY [46] := OTHERSY;
24300 END;
24400
24500
24600 INITPROCEDURE;
24700 BEGIN
24800 MESSAGE := 'ERROR IN BLOCKSTRUCTURE';
24900 DIGITS := ['0'..'9'];
25000 LETTERS := ['A'..'Z'];
25100 ALPHANUM := ['0'..'9','A'..'Z'] %LETTERS OR DIGITS\;
25200 DECSYM := [LABELSY..VARSY];
25300 PROSYM := [FUNCTIONSY..INITPROCSY];
25400 ENDSYM := [FUNCTIONSY..EOBSY]; %PROSYM OR ENDSYMBOLS\
25500 BEGSYM := [BEGINSY..IFSY];
25600 RELEVANTSYM := [LABELSY..INITPROCSY %DECSYM OR PROSYM\,BEGINSY,FORWARDSY,EXTERNSY,EOBSY];
25700 END;
25800
25900 PROCEDURE INIT;
26000 BEGIN (*INIT*)
26100 I := 0;
26200 FEED := 4;
26300 BUFFLEN := 0;
26400 BUFFMARK := 0;
26500 BUFFERPTR := 2;
26600 BUFFINDEX := 0;
26700 REALLINCNT:= 0;
26800 LINECNT :=0;
26900 BLOCKNR := 0;
27000 LEVEL := 0;
27100 PAGECNT := 1;
27200 PAGECNT2 := 0;
27300 SEQUENCE := TRUE;
27400 FAST := FALSE;
27500 INCREMENT := 100;
27600 EOB := FALSE;
27700 ERRFLAG := FALSE;
27800 EOLINE := TRUE;
27900 GOTOINLINE := FALSE;
28000 PROCSTRUCDATA.EXISTS := FALSE;
28100 OLDSPACES := FALSE;
28200 CH := ' ';
28300 BMARKTEXT := ' ';
28400 EMARKTEXT := ' ';
28500 SY := ' ';
28600 TIMEANDDAY := ' : : ';
28700 FOR CH := 'A' TO 'Z' DO FIRSTNAME [CH] := NIL;
28800 FOR CH := ' ' TO '←' DO DELSY [CH] := OTHERSY;
28900 DELSY ['('] := LPARENT;
29000 DELSY [')'] := RPARENT;
29100 DELSY ['['] := LPARENT;
29200 DELSY [']'] := RPARENT;
29300 DELSY [';'] := SEMICOLON;
29400 DELSY ['.'] := POINT;
29500 DELSY [':'] := COLON;
29600 FOR I := -1 TO 148 DO BUFFER [I] := ' ';
29700 I := 0;
29800 NEW (FIRSTNAME['M']);
29900 LISTPTR := FIRSTNAME ['M'];
30000 WITH FIRSTNAME ['M']↑ DO BEGIN
30100 NAME := 'MAIN. ';
30200 LLINK := NIL;
30300 RLINK := NIL;
30400 NEW (FIRST);
30500 LAST := FIRST;
30600 PROCVAR := PROC;
30700 WITH LAST↑ DO BEGIN
30800 LINENR := LINECNT;
30900 CONTLINK := NIL;
31000 END;
31100 NEW (CALLED);
31200 WITH CALLED↑ DO BEGIN
31300 PROCNAME := FIRSTNAME ['M'];
31400 NEXTPROC := NIL;
31500 NEW (FIRST);
31600 FIRST↑.LINENR := 0;
31700 FIRST↑.CONTLINK := NIL;
31800 LAST := FIRST;
31900 END;
32000 NEW (CALLEDBY);
32100 WITH CALLEDBY↑ DO BEGIN
32200 PROCNAME := FIRSTNAME ['M'];
32300 NEXTPROC := NIL;
32400 NEW (FIRST);
32500 FIRST↑.LINENR := 0;
32600 FIRST↑.CONTLINK := NIL;
32700 LAST := FIRST;
32800 END;
32900 END;
33000 NEW (PROCSTRUCF);
33100 WITH PROCSTRUCF↑ DO BEGIN
33200 PROCNAME := FIRSTNAME ['M'];
33300 NEXTPROC := NIL;
33400 LINENR := 0;
33500 PROCLEVEL:= 0;
33600 END;
33700 PROCSTRUCL := PROCSTRUCF;
33800 END %INIT\;
33900
34000
34100 PROCEDURE DATUM;
34200 %SET UP TIME AND DATE\
34300 VAR
34400 DATUM : PACKED ARRAY [1..9] OF CHAR;
34500 HOUR,MIN,SEC,I : INTEGER;
34600 BEGIN
34700 (*DATE(DATUM);****************************** *)
34800 FOR I := 1 TO 9 DO TIMEANDDAY[I] := DATUM[I];
34900 (**********TIME(I);*************** *)
35000 I := I DIV 1000;
35100 HOUR := I DIV 3600;
35200 I := I MOD 3600;
35300 MIN := I DIV 60;
35400 SEC := I MOD 60;
35500 TIMEANDDAY[17] := CHR (60B+HOUR DIV 10);
35600 TIMEANDDAY[18] := CHR (60B+HOUR MOD 10);
35700 TIMEANDDAY[20] := CHR (60B+MIN DIV 10);
35800 TIMEANDDAY[21] := CHR (60B+MIN MOD 10);
35900 TIMEANDDAY[23] := CHR (60B+SEC DIV 10);
36000 TIMEANDDAY[24] := CHR (60B+SEC MOD 10);
36100 END;
36200
36300 PROCEDURE HEADER;
36400 %PRINT TOP OF FORM AND HEADER ON LIST OUTPUT\
36500 BEGIN %HEADER\
36600 PAGECNT2 := PAGECNT2 + 1;
36700 REALLINCNT := 0;
36800 IF NOT FAST THEN BEGIN
36900 PAGE;
37000 WRITELN ('PAGE ':20,PAGECNT:3,'-',PAGECNT2:3,' ':15,OUTPUTFILE.FILENAME:6,
37100 ' ':9,TIMEANDDAY);
37200 WRITELN
37300 END;
37400 END %HEADER\;
37500
37600
37700 PROCEDURE NEWPAGE;
37800 BEGIN %NEWPAGE\
37900 PAGECNT2 := 0;
38000 PAGECNT := PAGECNT + 1;
38100 WRITE(NEWFIL, CHR(CR), CHR(FF));
38200 HEADER;
38300 IF EOLN (INPUT) THEN READLN;
38400 LINECNT := 0;
38500 REALLINCNT := 0;
38600 END %NEWPAGE\;
38700
38800 PROCEDURE NEWLINE;
38900 BEGIN
39000 IF REALLINCNT = MAXLINE THEN HEADER;
39100 LINECNT := LINECNT + 1;
39200 REALLINCNT := REALLINCNT + 1;
39300 %IF SEQUENCE THEN PUTLINNR...\
39400 END;
39500
39600 PROCEDURE WRTELINE (POSITION %LETZTES ZU DRUCKENDES ZEICHEN IM PUFFER\: INTEGER);
39700 VAR
39800 I, J, TABCNT, LSPACES : INTEGER; %MARKIERT ERSTES ZU DRUCKENDES ZEICHEN\
39900 BEGIN %WRTELINE\
40000 POSITION := POSITION - 2;
40100 IF POSITION > 0 THEN BEGIN
40200 I := BUFFMARK + 1;
40300 WHILE (BUFFER [I] = ' ') AND (I <= POSITION) DO I := I + 1;
40400 BUFFMARK := POSITION;
40500 WHILE (BUFFER [POSITION] = ' ') AND (I < POSITION) DO POSITION := POSITION - 1;
40600 IF I <= POSITION THEN BEGIN
40700 NEWLINE;
40800 IF NOT FAST THEN BEGIN
40900 IF GOTOINLINE THEN BEGIN
41000 WRITE('****GOTO****');
41100 GOTOINLINE := FALSE;
41200 END
41300 ELSE IF BMARKTEXT # ' ' THEN BEGIN
41400 WRITE (BMARKTEXT, BMARKNR : 4, ' ');
41500 BMARKTEXT := ' ';
41600 END
41700 ELSE IF EMARKTEXT # ' ' THEN BEGIN
41800 WRITE (' ',EMARKTEXT,EMARKNR : 4,' ');
41900 EMARKTEXT := ' ';
42000 END
42100 ELSE WRITE (CHR(HT),' ');
42200 WRITE (LINECNT * INCREMENT : 5,' ');
42300 END;
42400 IF NOT OLDSPACES THEN LASTSPACES := SPACES;
42500 %USE TABS AND SPACES TO MAKE INDENTATION\
42600 TABCNT := LASTSPACES DIV 8;
42700 LSPACES := LASTSPACES MOD 8;
42800 FOR TABCNT := TABCNT DOWNTO 1 DO BEGIN
42900 WRITE(NEWFIL, CHR(HT)); WRITE(CHR(HT))
43000 END;
43100 IF NOT FAST THEN BEGIN
43200 IF LASTSPACES > 7 THEN WRITE(' ');
43300 %COMPENSATE FOR THE FIRST TAB, WHICH IS SHORT\
43400 WRITE(' ': LSPACES);
43500 END;
43600 WRITE(NEWFIL, ' ': LSPACES);
43700 IF (POSITION - I + LASTSPACES + 1) > MAXCH THEN BEGIN
43800 IF REALLINCNT = MAXLINE THEN BEGIN
43900 FOR I := I TO MAXCH + I - LASTSPACES - 1 DO BEGIN
44000 WRITE (BUFFER[I]);
44100 WRITE(NEWFIL, BUFFER[I]);
44200 END;
44300 WRITELN;
44400 HEADER;
44500 END;
44600 REALLINCNT := REALLINCNT + 1;
44700 END;
44800 IF FAST THEN FOR J := I TO POSITION DO WRITE(NEWFIL, BUFFER[J])
44900 ELSE BEGIN
45000 FOR J := I TO POSITION DO BEGIN
45100 WRITE (BUFFER [J]);
45200 WRITE(NEWFIL, BUFFER[J]);
45300 END;
45400 WRITELN;
45500 END;
45600 WRITELN(NEWFIL);
45700 IF ((LINENB = ' ') AND (POSITION = BUFFLEN)) OR (MAXINC <= LINECNT) THEN NEWPAGE;
45800 END;
45900 END;
46000 LASTSPACES := SPACES;
46100 OLDSPACES := FALSE;
46200 THENDO := FALSE;
46300 END %WRTELINE\ ;
46400
46500 PROCEDURE READLINE;
46600 %HANDLES LEADING BLANKS AND BLANK LINES, READS NEXT NONBLANK LINE
46700 (WITHOUT LEADING BLANKS) INTO BUFFER\
46800 VAR
46900 CH : CHAR;
47000 BEGIN %READLINE\
47100 %ENTERED AT THE BEGINNING OF A LINE\
47200 REPEAT
47300 WHILE EOLN (INPUT) AND NOT EOF (INPUT) DO BEGIN
47400 %IS THIS A PAGE MARK?\
47500 GETLINENR (LINENB);
47600 READLN;
47700 IF LINENB = ' ' THEN NEWPAGE ELSE BEGIN
47800 %HANDLE BLANK LINE\
47900 NEWLINE;
48000 IF NOT FAST THEN WRITELN (CHR(HT),' ',LINECNT * INCREMENT : 5);
48100 WRITELN(NEWFIL);
48200 IF MAXINC <= LINECNT THEN NEWPAGE;
48300 END;
48400 END;
48500 READ (CH);
48600 UNTIL (CH # ' ') OR (EOF (INPUT));
48700 BUFFLEN := 0;
48800 %READ IN THE LINE\
48900 LOOP
49000 BUFFLEN := BUFFLEN + 1;
49100 BUFFER [BUFFLEN] := CH;
49200 EXIT IF (EOLN (INPUT) OR (BUFFLEN = 147));
49300 READ (CH);
49400 END;
49500 BUFFER[BUFFLEN+1] := ' '; %SO WE CAN ALWAYS BE ONE CHAR AHEAD\
49600 IF NOT EOLN (INPUT) THEN BEGIN
49700 WRITELN (TTY);
49800 WRITELN (TTY,'LINE ',(LINECNT+1)*INCREMENT : 5, '/', PAGECNT: 2, ' TOO LONG');
49900 WRITELN (' ' : 17,' **** NEXT LINE TOO LONG ****');
50000 END
50100 ELSE IF NOT EOF (INPUT) THEN BEGIN
50200 GETLINENR (LINENB);
50300 READLN;
50400 END;
50500 BUFFERPTR := 1;
50600 BUFFMARK := 0;
50700 END %READLINE\ ;
50800
50900 PROCEDURE READBUFFER;
51000 %READS A CHARACTER FROM THE INPUT BUFFER\
51100 BEGIN %READBUFFER\
51200 %IF READING PAST THE EXTRA BLANK ON THE END, GET A NEW LINE\
51300 IF EOLINE THEN BEGIN
51400 WRTELINE (BUFFERPTR);
51500 CH := ' ';
51600 IF EOF (INPUT) THEN EOB := TRUE ELSE READLINE;
51700 END
51800 ELSE BEGIN
51900 CH := BUFFER [BUFFERPTR];
52000 BUFFERPTR := BUFFERPTR + 1;
52100 END;
52200 EOLINE := BUFFERPTR = BUFFLEN + 2;
52300 END %READBUFFER\ ;
52400
52500 FUNCTION RESWORD: BOOLEAN ;
52600 %DETERMINES IF THE CURRENT IDENTIFIER IS A RESERVED WORD\
52700 LABEL 1;
52800 VAR
52900 I: INTEGER;
53000 BEGIN %RESWORD\
53100 RESWORD:= FALSE;
53200 FOR I:=RESNUM[SY[1]] TO RESNUM[SUCC(SY[1])] - 1
53300 DO IF RESLIST[ I ] = SY THEN BEGIN
53400 RESWORD := TRUE;
53500 SYTY := RESSY [I];
53600 IF SYTY = GOTOSY THEN GOTOINLINE := TRUE;
53700 GOTO 1;
53800 END;
53900 1:
54000 END %RESWORD\ ;
54100
54200 PROCEDURE FINDNAME(DOUBLEDECF, DOUBLEDECL: DBLEDECLIST; CURPROC: LISTPTRTY);
54300 LABEL 1;
54400 VAR
54500 PROCPTR : PROCCALLTY; %ZEIGER AUF RUFENDE BZW. GERUFENE PROZEDUR BEI DEREN VERKETTUNG\
54600 LPTR: LISTPTRTY; %ZEIGER AUF DEN VORGAENGER IM BAUM\
54700 ZPTR : LINEPTRTY; %ZEIGER AUF DIE VORLETZTE ZEILENNUMMER IN EINER KETTE\
54800 RIGHT: BOOLEAN; %MERKVARIABLE FUER DIE VERZWEIGUNG IM BAUM\
54900 INDEXCH : CHAR; %INDEXVARIABLE FUER DAS FELD DER STARTZEIGER (FIRSTNAME)\
55000
55100
55200 PROCEDURE FINDPROC (COMP : LISTPTRTY);
55300 %BUILDS UP THE LISTS OF CALLEDBY AND CALLED\
55400 VAR
55500 PROCCALLPTR : PROCCALLTY; %MERK SICH LETZTE PROZEDUR FALLS EINE NEUE ERZEUGT WERDEN MUSS\
55600 BEGIN %FINDPROC\
55700 WHILE (PROCPTR↑.PROCNAME # COMP) AND (PROCPTR↑.NEXTPROC # NIL) DO
55800 PROCPTR := PROCPTR↑.NEXTPROC;
55900 IF PROCPTR↑.PROCNAME = COMP THEN BEGIN
56000 ZPTR := PROCPTR↑.LAST;
56100 IF (ZPTR↑.LINENR # LINECNT+1) OR (ZPTR↑.PAGENR # PAGECNT) THEN BEGIN
56200 NEW (PROCPTR↑.LAST);
56300 WITH PROCPTR↑.LAST↑ DO BEGIN
56400 LINENR := LINECNT + 1;
56500 PAGENR := PAGECNT;
56600 CONTLINK := NIL;
56700 END;
56800 ZPTR↑.CONTLINK := PROCPTR↑.LAST;
56900 END;
57000 END
57100 ELSE BEGIN
57200 PROCCALLPTR := PROCPTR;
57300 NEW (PROCPTR);
57400 WITH PROCPTR↑ DO BEGIN
57500 PROCNAME := COMP;
57600 NEXTPROC := NIL;
57700 NEW (FIRST);
57800 WITH FIRST↑ DO BEGIN
57900 LINENR := LINECNT + 1;
58000 PAGENR := PAGECNT;
58100 CONTLINK := NIL;
58200 END;
58300 LAST := FIRST;
58400 END;
58500 PROCCALLPTR↑.NEXTPROC := PROCPTR;
58600 END;
58700 END %FINDPROC\ ;
58800
58900 PROCEDURE NEWPROCEDURE;
59000 BEGIN %NEWPROCEDURE\
59100 WITH LISTPTR↑ DO BEGIN
59200 PROCVAR := PROCDEC;
59300 NEW (CALLEDBY);
59400 WITH CALLEDBY↑ DO BEGIN
59500 PROCNAME := CURPROC;
59600 NEXTPROC := NIL;
59700 NEW (FIRST);
59800 WITH FIRST↑ DO BEGIN
59900 LINENR := LINECNT + 1;
60000 PAGENR := PAGECNT;
60100 CONTLINK := NIL;
60200 END;
60300 LAST := FIRST;
60400 END;
60500 NEW (CALLED);
60600 WITH CALLED↑ DO BEGIN
60700 PROCNAME := FIRSTNAME ['M'];
60800 NEXTPROC := NIL;
60900 NEW (FIRST);
61000 WITH FIRST↑ DO BEGIN
61100 LINENR := LINECNT + 1;
61200 PAGENR := PAGECNT;
61300 CONTLINK := NIL;
61400 END;
61500 LAST := FIRST;
61600 END;
61700 END;
61800 END %NEWPROCEDURE\ ;
61900
62000 BEGIN %FINDNAME\
62100 INDEXCH := SY [1];
62200 LISTPTR := FIRSTNAME [INDEXCH];
62300 %SEARCH IN THE TREE FOR THE IDENTIFIER\
62400 WHILE LISTPTR # NIL DO BEGIN
62500 LPTR:= LISTPTR;
62600 IF SY = LISTPTR↑.NAME THEN BEGIN
62700 ZPTR := LISTPTR↑.LAST;
62800 IF (ZPTR↑.LINENR # LINECNT+1) OR (ZPTR↑.PAGENR # PAGECNT) THEN BEGIN
62900 NEW (LISTPTR↑.LAST);
63000 WITH LISTPTR↑.LAST↑ DO BEGIN
63100 LINENR := LINECNT + 1;
63200 PAGENR := PAGECNT;
63300 CONTLINK := NIL;
63400 END;
63500 ZPTR↑.CONTLINK := LISTPTR↑.LAST;
63600 END;
63700 IF LISTPTR↑.PROCVAR # NOTROUT THEN BEGIN
63800 IF LISTPTR↑.PROCVAR = FUNC THEN WHILE CH = ' ' DO BEGIN
63900 SYLENG := SYLENG + 1;
64000 READBUFFER;
64100 END;
64200 %IF A PROCEDURE OR FUNCTION CALL, INCLUDE IT IN CALLING LISTS\
64300 IF (CH # ':') OR (LISTPTR↑.PROCVAR = PROC) THEN BEGIN
64400 PROCPTR := LISTPTR↑.CALLEDBY;
64500 FINDPROC (CURPROC);
64600 PROCPTR := CURPROC↑.CALLED;
64700 FINDPROC (LISTPTR);
64800 END
64900 END
65000 ELSE IF PROCDEC # NOTROUT THEN BEGIN
65100 IF DOUBLEDECF = NIL THEN BEGIN
65200 NEW (DOUBLEDECF);
65300 DOUBLEDECL := DOUBLEDECF;
65400 END
65500 ELSE BEGIN
65600 NEW (DOUBLEDECL↑.NEXTPROC);
65700 DOUBLEDECL := DOUBLEDECL↑.NEXTPROC;
65800 END;
65900 DOUBLEDECL↑.NEXTPROC := NIL;
66000 DOUBLEDECL↑.PROCORT := LISTPTR;
66100 NEWPROCEDURE;
66200 END;
66300 GOTO 1;
66400 END
66500 ELSE IF SY > LISTPTR↑.NAME THEN BEGIN
66600 LISTPTR:= LISTPTR↑.RLINK;
66700 RIGHT:= TRUE;
66800 END
66900 ELSE BEGIN
67000 LISTPTR:= LISTPTR↑.LLINK;
67100 RIGHT:= FALSE;
67200 END;
67300 END;
67400 %IF CONTROL COMES HERE, THE IDENTIFIER IS UNKNOWN\
67500 NEW (LISTPTR);
67600 WITH LISTPTR↑ DO BEGIN
67700 NAME := SY;
67800 LLINK := NIL;
67900 RLINK := NIL;
68000 END;
68100 IF FIRSTNAME [INDEXCH] = NIL THEN FIRSTNAME [INDEXCH] := LISTPTR
68200 ELSE IF RIGHT THEN LPTR↑.RLINK := LISTPTR ELSE LPTR↑.LLINK := LISTPTR;
68300 WITH LISTPTR↑ DO BEGIN
68400 NEW (FIRST);
68500 WITH FIRST↑ DO BEGIN
68600 LINENR := LINECNT + 1;
68700 PAGENR := PAGECNT;
68800 CONTLINK := NIL;
68900 END;
69000 LAST := FIRST ;
69100 IF PROCDEC = NOTROUT THEN BEGIN
69200 PROCVAR := NOTROUT;
69300 CALLED := NIL;
69400 CALLEDBY := NIL;
69500 END
69600 ELSE NEWPROCEDURE;
69700 END;
69800 1:
69900 PROCDEC := NOTROUT;
70000 END %FINDNAME\ ;
70100
70200 PROCEDURE BLOCK;
70300 VAR
70400 DOUBLEDECF, %ZEIGER AUF ERSTE UND LETZTE VARIABLE DIE ALS PROCEDURE\
70500 DOUBLEDECL : DBLEDECLIST; %IN DIESEM BLOCK DOPPELT DEKLARIERT WURDEN\
70600 CURPROC : LISTPTRTY; %ZEIGER AUF DIE PROZEDUR IN DEREN ANWEISUNGSTEIL DAS PROGRAMM SICH BEFINDET\
70700
70800 PROCEDURE ERROR (ERRNR : ERRKINDS);
70900 BEGIN %ERROR\
71000 ERRFLAG := TRUE;
71100 REALLINCNT := REALLINCNT + 1; %COUNT THE LINE OF THE ERROR MESSAGE ON THE LPT: FILE\
71200 WRITE (' ':17,' **** ');
71300 CASE ERRNR OF
71400 ERRINBLKSTR : WRITELN(SY,' ? ? ? ',MESSAGE);
71500 MISSGENDUNTIL : WRITELN('MISSING ''END'' OR ''UNTIL'' NUMBER ',EMARKNR : 4);
71600 MISSGTHEN : WRITELN('MISSING ''THEN'' NUMBER ',EMARKNR : 4);
71700 MISSGOF : WRITELN('MISSING ''OF'' TO ''CASE'' NUMBER ',BMARKNR : 4);
71800 MISSGEXIT : WRITELN('MISSING ''EXIT'' IN ''LOOP'' ',EMARKNR : 4);
71900 MISSGRPAR : WRITELN('MISSING RIGHT PARENTHESIS');
72000 MISSGQUOTE : WRITELN('MISSING CLOSING QUOTE ON THIS LINE')
72100 END;
72200 WRITELN(TTY, 'ERROR AT ', LINECNT*INCREMENT: 5, '/', PAGECNT:2);
72300 END %ERROR\ ;
72400
72500 PROCEDURE NEWLINEHERE;
72600 BEGIN
72700 WRTELINE(BUFFERPTR - SYLENG);
72800 END;
72900
73000 PROCEDURE SETLASTSPACES(I: INTEGER);
73100 BEGIN
73200 OLDSPACES := TRUE;
73300 LASTSPACES := I;
73400 END;
73500
73600 PROCEDURE MAYBESLS(I: INTEGER);
73700 BEGIN
73800 IF NOT OLDSPACES THEN SETLASTSPACES(I);
73900 END;
74000
74100 PROCEDURE INSYMBOL ;
74200 LABEL 1;
74300 VAR
74400 OLDSPACESMARK, %ALTER ZEICHENVORSCHUB BEI FORMATIERUNG VON KOMMENTAREN\
74500 I : INTEGER;
74600
74700
74800
74900 PROCEDURE PARENTHESE;
75000 VAR
75100 OLDSPACESMARK : INTEGER; %ALTER ZEICHENVORSCHUB BEI FORMATIERUNG VON KLAMMERN\
75200 BEGIN %PARENTHESE\
75300 OLDSPACESMARK := SPACES;
75400 MAYBESLS(SPACES);
75500 SPACES := LASTSPACES + BUFFERPTR - BUFFMARK - 2;
75600 %SKIP STUFF UNTIL WE SEEM TO BE OUT OF THE EXPRESSION\
75700 REPEAT
75800 INSYMBOL
75900 UNTIL SYTY IN [EXTERNSY..RPARENT,LABELSY..TYPESY,INITPROCSY..EXITSY,DOSY..FORWARDSY];
76000 SPACES := OLDSPACESMARK;
76100 OLDSPACES := TRUE;
76200 IF SYTY = RPARENT THEN INSYMBOL ELSE ERROR(MISSGRPAR);
76300 END %PARENTHESE\ ;
76400 BEGIN %INSYMBOL\
76500 SYLENG := 0;
76600 WHILE (CH IN ['←','(',' ','%','$','?','\','!','@']) AND NOT EOB DO BEGIN
76700 IF (CH = '%') OR (CH = '(') AND (BUFFER[BUFFERPTR] = '*') THEN BEGIN
76800 OLDSPACESMARK := SPACES;
76900 IF OLDSPACES THEN SPACES := LASTSPACES ELSE LASTSPACES := SPACES;
77000 SPACES := SPACES + BUFFERPTR - 1;
77100 OLDSPACES := TRUE;
77200 IF CH = '%' THEN REPEAT
77300 READBUFFER;
77400 UNTIL (CH = '\') OR EOB
77500 ELSE REPEAT
77600 READBUFFER
77700 UNTIL (CH = ')') AND (BUFFER[BUFFERPTR-2] = '*') OR EOB;
77800 SPACES := OLDSPACESMARK;
77900 OLDSPACES := TRUE;
78000 END
78100 ELSE IF CH = '(' THEN GOTO 1;
78200 READBUFFER;
78300 END;
78400 CASE CH OF
78500 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I',
78600 'J', 'K', 'L', 'M', 'N', 'O', 'P', 'Q',
78700 'R', 'S', 'T', 'U', 'V', 'W', 'X', 'Y',
78800 'Z':
78900 BEGIN
79000 SYLENG := 0;
79100 SY := ' ';
79200 REPEAT
79300 SYLENG := SYLENG + 1;
79400 IF SYLENG <= 10 THEN SY [SYLENG] := CH;
79500 READBUFFER;
79600 UNTIL NOT (CH IN (ALPHANUM + ['←']));
79700 IF NOT RESWORD THEN BEGIN
79800 SYTY := IDENT ;
79900 FINDNAME(DOUBLEDECF, DOUBLEDECL, CURPROC);
80000 END
80100 END;
80200 '0', '1', '2', '3', '4', '5', '6', '7', '8',
80300 '9':
80400 BEGIN
80500 REPEAT
80600 SYLENG := SYLENG + 1;
80700 READBUFFER;
80800 UNTIL NOT (CH IN DIGITS);
80900 SYTY := INTCONST;
81000 IF CH = 'B' THEN READBUFFER ELSE BEGIN
81100 IF CH = '.' THEN BEGIN
81200 REPEAT
81300 READBUFFER
81400 UNTIL NOT (CH IN DIGITS);
81500 SYTY := OTHERSY; SYLENG := 0; %REALS CAN'T BE LABELS\
81600 END;
81700 IF CH = 'E' THEN BEGIN
81800 READBUFFER;
81900 IF CH IN ['+','-'] THEN READBUFFER;
82000 WHILE CH IN DIGITS DO READBUFFER;
82100 SYTY := OTHERSY; SYLENG := 0; %REALS CAN'T BE LABELS\
82200 END;
82300 END;
82400 END;
82500 '''':
82600 BEGIN
82700 SYTY := STRGCONST;
82800 REPEAT
82900 READBUFFER;
83000 UNTIL (CH = '''') OR EOB OR EOLINE;
83100 IF CH # '''' THEN ERROR(MISSGQUOTE);
83200 READBUFFER;
83300 END;
83400 '"':
83500 BEGIN
83600 REPEAT
83700 READBUFFER
83800 UNTIL NOT (CH IN (DIGITS + ['A'..'F']));
83900 SYTY := INTCONST;
84000 END;
84100 ' ': SYTY := EOBSY; %END OF FILE\
84200 OTHERS:
84300 BEGIN
84400 1:
84500 SYTY := DELSY [CH];
84600 READBUFFER;
84700 IF SYTY = LPARENT THEN PARENTHESE ELSE IF (SYTY = COLON) AND (CH = '=') THEN BEGIN
84800 SYTY := OTHERSY;
84900 READBUFFER;
85000 END;
85100 END
85200 END;
85300 END %INSYMBOL\ ;
85400
85500 PROCEDURE RECDEF;
85600 VAR
85700 OLDSPACESMARK : INTEGER; %ALTER ZEICHENVORSCHUB BEI FORMATIERUNG VON RECORDS\
85800 PROCEDURE CASEDEF;
85900 VAR
86000 OLDSPACESMARK : INTEGER; %ALTER ZEICHENVORSCHUB BEI FORMATIERUNG VON VARIANT PARTS\
86100 PROCEDURE PARENTHESE;
86200 %HANDLES THE FORMATTING OF PARENTHESES INSIDE VARIANT PARTS\
86300 VAR
86400 OLDSPACESMARK : INTEGER; %SAVED VALUE OF 'SPACES'\
86500 BEGIN %PARENTHESE\
86600 OLDSPACESMARK := SPACES;
86700 MAYBESLS(SPACES);
86800 SPACES := SPACES + BUFFERPTR - 2;
86900 INSYMBOL;
87000 REPEAT
87100 CASE SYTY OF
87200 CASESY :
87300 BEGIN
87400 CASEDEF; DELSY['('] := LBRACK
87500 END;
87600 RECORDSY : RECDEF;
87700 OTHERS: INSYMBOL
87800 END;
87900 %UNTIL WE APPARENTLY LEAVE THE DECLARATION\
88000 UNTIL SYTY IN [STRGCONST..RPARENT,LABELSY..EXITSY,DOSY..BEGINSY,
88100 LOOPSY..FORWARDSY];
88200 SPACES := OLDSPACESMARK;
88300 OLDSPACES := TRUE;
88400 IF SYTY = RPARENT THEN INSYMBOL ELSE ERROR(MISSGRPAR);
88500 END %PARENTHESE\ ;
88600
88700 BEGIN %CASEDEF\
88800 %PREVENT THE OTHER 'PARENTHESE' FROM BEING CALLED ON '('\
88900 DELSY ['('] := LBRACK;
89000 OLDSPACESMARK := SPACES;
89100 MAYBESLS(SPACES);
89200 SPACES := BUFFERPTR - BUFFMARK + LASTSPACES - SYLENG + 3;
89300 INSYMBOL;
89400 REPEAT
89500 IF SYTY = LBRACK THEN PARENTHESE ELSE INSYMBOL
89600 UNTIL SYTY IN [UNTILSY..EXITSY,LABELSY..ENDSY,RPARENT,DOSY..BEGINSY];
89700 SPACES := OLDSPACESMARK;
89800 DELSY ['('] := LPARENT;
89900 END %CASEDEF\ ;
90000
90100 BEGIN %RECDEF\
90200 OLDSPACESMARK := SPACES;
90300 SETLASTSPACES(SPACES);
90400 SPACES := BUFFERPTR - BUFFMARK + SPACES - SYLENG - 2 + FEED;
90500 INSYMBOL;
90600 NEWLINEHERE;
90700 REPEAT
90800 CASE SYTY OF
90900 CASESY : CASEDEF;
91000 RECORDSY : RECDEF;
91100 OTHERS : INSYMBOL
91200 END;
91300 UNTIL SYTY IN [UNTILSY..EXITSY,LABELSY..ENDSY,DOSY..BEGINSY];
91400 NEWLINEHERE;
91500 OLDSPACES := TRUE;
91600 LASTSPACES := SPACES - FEED;
91700 SPACES := OLDSPACESMARK;
91800 IF SYTY = ENDSY THEN INSYMBOL ELSE ERROR(MISSGENDUNTIL);
91900 END %RECDEF\ ;
92000
92100 PROCEDURE STATEMENT;
92200 VAR
92300 OLDSPACESMARK, %SPACES AT ENTRY OF THIS PROCEDURE\
92400 CURBLOCKNR : INTEGER; %AKTUELLE BLOCKNUMMER\
92500
92600 PROCEDURE COMPSTAT;
92700 BEGIN %COMPSTAT\
92800 BMARKTEXT := 'B';
92900 MAYBESLS(SPACES - FEED);
93000 INSYMBOL;
93100 NEWLINEHERE;
93200 LOOP
93300 LOOP
93400 STATEMENT;
93500 EXIT IF SYTY # SEMICOLON;
93600 INSYMBOL
93700 END;
93800 EXIT IF SYTY IN [ENDSY,EOBSY,PROCEDURESY,FUNCTIONSY];
93900 ERROR (ERRINBLKSTR);
94000 IF NOT (SYTY IN BEGSYM) THEN INSYMBOL ;
94100 END;
94200 NEWLINEHERE;
94300 EMARKTEXT := 'E';
94400 EMARKNR := CURBLOCKNR;
94500 SETLASTSPACES(SPACES-FEED);
94600 IF SYTY = ENDSY THEN BEGIN
94700 INSYMBOL ;
94800 NEWLINEHERE;
94900 END
95000 ELSE ERROR (MISSGENDUNTIL);
95100 END %COMPSTAT\ ;
95200
95300 PROCEDURE CASESTAT;
95400 VAR
95500 OLDSPACESMARK : INTEGER; %SAVED VALUE OF 'SPACES'\
95600 BEGIN %CASESTAT\
95700 BMARKTEXT := 'C';
95800 MAYBESLS(SPACES-FEED);
95900 INSYMBOL;
96000 STATEMENT;
96100 IF SYTY = OFSY THEN WRTELINE (BUFFERPTR) ELSE ERROR (MISSGOF);
96200 LOOP
96300 REPEAT
96400 REPEAT
96500 INSYMBOL
96600 UNTIL SYTY IN [COLON,FUNCTIONSY..EOBSY];
96700 IF SYTY = COLON THEN BEGIN
96800 OLDSPACESMARK := SPACES;
96900 LASTSPACES := SPACES;
97000 SPACES := BUFFERPTR - BUFFMARK + SPACES - 2;
97100 OLDSPACES := TRUE;
97200 INSYMBOL;
97300 STATEMENT;
97400 SPACES := OLDSPACESMARK;
97500 END;
97600 UNTIL SYTY IN ENDSYM;
97700 EXIT IF SYTY IN [ENDSY,EOBSY,PROCEDURESY,FUNCTIONSY];
97800 ERROR (ERRINBLKSTR);
97900 END;
98000 NEWLINEHERE;
98100 EMARKTEXT := 'E';
98200 EMARKNR := CURBLOCKNR;
98300 LASTSPACES := SPACES-FEED;
98400 OLDSPACES := TRUE;
98500 IF SYTY = ENDSY THEN BEGIN
98600 INSYMBOL ;
98700 NEWLINEHERE;
98800 END
98900 ELSE ERROR (MISSGENDUNTIL);
99000 END %CASESTAT\ ;
99100
99200 PROCEDURE LOOPSTAT;
99300 BEGIN %LOOPSTAT\
99400 BMARKTEXT := 'L';
99500 MAYBESLS(SPACES - FEED);
99600 INSYMBOL;
99700 NEWLINEHERE;
99800 LOOP
99900 STATEMENT;
00100 EXIT IF SYTY # SEMICOLON;
00200 INSYMBOL
00300 END;
00400 IF SYTY = EXITSY THEN BEGIN
00500 NEWLINEHERE;
00600 OLDSPACES := TRUE;
00700 LASTSPACES := SPACES-FEED;
00800 EMARKTEXT := 'X';
00900 EMARKNR := CURBLOCKNR;
01000 INSYMBOL; INSYMBOL;
01100 END
01200 ELSE ERROR(MISSGEXIT);
01300 LOOP
01400 LOOP
01500 STATEMENT;
01600 EXIT IF SYTY # SEMICOLON;
01700 INSYMBOL
01800 END;
01900 EXIT IF SYTY IN [ENDSY,EOBSY,PROCEDURESY,FUNCTIONSY];
02000 ERROR (ERRINBLKSTR);
02100 IF NOT (SYTY IN BEGSYM) THEN INSYMBOL ;
02200 END;
02300 NEWLINEHERE;
02400 EMARKTEXT := 'E';
02500 EMARKNR := CURBLOCKNR;
02600 LASTSPACES := SPACES-FEED;
02700 OLDSPACES := TRUE;
02800 IF SYTY = ENDSY THEN BEGIN
02900 INSYMBOL ;
03000 NEWLINEHERE;
03100 END
03200 ELSE ERROR (MISSGENDUNTIL);
03300 END %LOOPSTAT\ ;
03400
03500 PROCEDURE IFSTAT;
03600 VAR
03700 OLDSPACESMARK: INTEGER;
03800 BEGIN %IFSTAT\
03900 OLDSPACESMARK := SPACES;
04000 BMARKTEXT := 'I';
04100 MAYBESLS(SPACES - FEED); %DON'T INDENT THE 'IF'\
04200 %MAKE 'THEN' AND 'ELSE' LINE UP WITH 'IF' UNLESS ON SAME LINE\
04300 SPACES := LASTSPACES + BUFFERPTR - BUFFMARK + FEED - 4;
04400 INSYMBOL;
04500 STATEMENT; %WILL EAT THE EXPRESSION AND STOP ON A KEYWORD\
04600 IF SYTY = THENSY THEN BEGIN
04700 MAYBESLS(SPACES-FEED);
04800 THENDO := TRUE; %SUPPRESS FURTHER INDENTATION FROM A 'DO'\
04900 EMARKTEXT := 'T';
05000 EMARKNR := CURBLOCKNR;
05100 INSYMBOL;
05200 STATEMENT;
05300 END
05400 ELSE ERROR (MISSGTHEN);
05500 IF SYTY = ELSESY THEN BEGIN
05600 EMARKTEXT := 'S';
05700 EMARKNR := CURBLOCKNR;
05800 MAYBESLS(SPACES-FEED);
05900 THENDO := TRUE;
06000 INSYMBOL;
06100 STATEMENT;
06200 END;
06300 OLDSPACES := TRUE; %PRESERVE INDENTATION OF STATEMENT\
06400 NEWLINEHERE;
06500 SPACES := OLDSPACESMARK;
06600 END %IFSTAT\ ;
06700
06800
06900 PROCEDURE LABELSTAT;
07000 BEGIN %LABELSTAT\
07100 LASTSPACES := LEVEL * FEED;
07200 OLDSPACES := TRUE;
07300 INSYMBOL;
07400 NEWLINEHERE;
07500 END %LABELSTAT\ ;
07600
07700 PROCEDURE REPEATSTAT;
07800 BEGIN %REPEATSTAT\
07900 BMARKTEXT := 'R';
08000 MAYBESLS(SPACES - FEED);
08100 INSYMBOL ;
08200 NEWLINEHERE;
08300 LOOP
08400 LOOP
08500 STATEMENT;
08600 EXIT IF SYTY # SEMICOLON;
08700 INSYMBOL
08800 END;
08900 EXIT IF SYTY IN [UNTILSY,EOBSY,PROCEDURESY,FUNCTIONSY];
09000 ERROR (ERRINBLKSTR);
09100 IF NOT (SYTY IN BEGSYM) THEN INSYMBOL;
09200 END;
09300 NEWLINEHERE;
09400 EMARKTEXT := 'U';
09500 EMARKNR := CURBLOCKNR;
09600 OLDSPACES := TRUE;
09700 LASTSPACES := SPACES-FEED;
09800 IF SYTY = UNTILSY THEN BEGIN
09900 INSYMBOL;
10000 STATEMENT;
10100 NEWLINEHERE;
10200 END
10300 ELSE ERROR (MISSGENDUNTIL);
10400 END %REPEATSTAT\ ;
10500
10600 BEGIN %STATEMENT\
10700 OLDSPACESMARK := SPACES; %SAVE THE INCOMING VALUE OF SPACES TO BE ABLE TO RESTORE IT\
10800 IF SYTY = INTCONST THEN BEGIN
10900 INSYMBOL;
11000 IF SYTY = COLON THEN LABELSTAT;
11100 END;
11200 IF SYTY IN BEGSYM THEN BEGIN
11300 BLOCKNR := BLOCKNR + 1;
11400 CURBLOCKNR := BLOCKNR;
11500 BMARKNR := CURBLOCKNR;
11600 IF NOT THENDO THEN BEGIN
11700 NEWLINEHERE;
11800 SPACES := SPACES + FEED;
11900 END;
12000 CASE SYTY OF
12100 BEGINSY : COMPSTAT;
12200 LOOPSY : LOOPSTAT;
12300 CASESY : CASESTAT;
12400 IFSY : IFSTAT;
12500 REPEATSY: REPEATSTAT
12600 END;
12700 END
12800 ELSE BEGIN
12900 WHILE NOT (SYTY IN [SEMICOLON,FUNCTIONSY..RECORDSY]) DO INSYMBOL;
13000 IF SYTY = DOSY THEN BEGIN
13100 IF NOT THENDO THEN BEGIN
13200 MAYBESLS(SPACES);
13300 SPACES := SPACES + FEED;
13400 THENDO := TRUE;
13500 END;
13600 INSYMBOL;
13700 STATEMENT;
13800 NEWLINEHERE;
13900 END;
14000 END;
14100 SPACES := OLDSPACESMARK;
14200 END %STATEMENT\ ;
14300
14400 BEGIN %BLOCK\
14500 DOUBLEDECF := NIL;
14600 LEVEL := LEVEL + 1;
14700 CURPROC := LISTPTR;
14800 SPACES := LEVEL * FEED;
14900 REPEAT
15000 INSYMBOL
15100 UNTIL SYTY IN RELEVANTSYM;
15200 %HANDLE NESTING LIST\
15300 IF PROCSTRUCDATA.EXISTS THEN BEGIN
15400 IF NOT (SYTY IN [FORWARDSY,EXTERNSY]) THEN BEGIN
15500 NEW(PROCSTRUCL↑.NEXTPROC);
15600 PROCSTRUCL := PROCSTRUCL↑.NEXTPROC;
15700 PROCSTRUCL↑ := PROCSTRUCDATA.ITEM
15800 END;
15900 PROCSTRUCDATA.EXISTS := FALSE
16000 END;
16100 REPEAT
16200 FWDDECL := FALSE;
16300 WHILE SYTY IN DECSYM DO BEGIN
16400 NEWLINEHERE;
16500 SPACES := SPACES - FEED;
16600 WRTELINE (BUFFERPTR);
16700 SPACES := SPACES + FEED;
16800 REPEAT
16900 INSYMBOL;
17000 IF SYTY = RECORDSY THEN RECDEF;
17100 UNTIL SYTY IN RELEVANTSYM;
17200 END;
17300 WHILE SYTY IN PROSYM DO BEGIN
17400 NEWLINEHERE;
17500 OLDSPACES := TRUE;
17600 IF SYTY # INITPROCSY THEN BEGIN
17700 IF SYTY = PROCEDURESY THEN PROCDEC := PROC ELSE PROCDEC := FUNC;
17800 INSYMBOL;
17900 WITH PROCSTRUCDATA DO BEGIN
18000 EXISTS := TRUE;
18100 ITEM.PROCNAME := LISTPTR;
18200 ITEM.NEXTPROC := NIL;
18300 ITEM.LINENR := LINECNT+1;
18400 ITEM.PAGENR := PAGECNT;
18500 ITEM.PROCLEVEL := LEVEL
18600 END;
18700 END;
18800 BLOCK;
18900 IF SYTY = SEMICOLON THEN INSYMBOL;
19000 END;
19100 %FORWARD AND EXTERNAL DECLARATIONS MAY COME BEFORE 'VAR', ETC.\
19200 UNTIL NOT FWDDECL;
19300 LEVEL := LEVEL - 1;
19400 SPACES := LEVEL * FEED;
19500 IF (LEVEL=0) AND (SYTY=POINT) THEN WRITELN(TTY,'(NO MAIN PROGRAM)') ELSE BEGIN
19600 IF NOT (SYTY IN [BEGINSY,FORWARDSY,EXTERNSY,EOBSY]) THEN BEGIN
19700 ERROR (ERRINBLKSTR);
19800 WHILE NOT (SYTY IN [BEGINSY,FORWARDSY,EXTERNSY,EOBSY]) DO INSYMBOL
19900 END;
20000 IF SYTY = BEGINSY THEN STATEMENT ELSE BEGIN
20100 FWDDECL := TRUE;
20200 INSYMBOL;
20300 IF SYTY = LANGSY THEN INSYMBOL
20400 END;
20500 END;
20600 WHILE DOUBLEDECF # NIL DO BEGIN
20700 DOUBLEDECF↑.PROCORT↑.PROCVAR := NOTROUT;
20800 DOUBLEDECF := DOUBLEDECF↑.NEXTPROC;
20900 END;
21000 IF LEVEL = 0 THEN BEGIN
21100 IF SYTY # POINT THEN BEGIN
21200 WRITELN (TTY,'MISSING POINT AT PROGRAM END');
21300 WRITELN (TTY);
21400 WRITELN (' ' : 17, ' **** MISSING POINT AT PROGRAM END ****');
21500 INSYMBOL;
21600 END;
21700 WHILE SYTY # EOBSY DO INSYMBOL;
21800 END;
21900 END %BLOCK\ ;
22000 PROCEDURE PRINTLISTE;
22100
22200 VAR
22300 FIRSTPROC,LASTPROC, %ZEIGER ZUM DURCHHANGELN DURCH DIE BAEUME UND LISTEN BEIM AUSDRUCKEN\
22400 PRED : LISTPTRTY;
22500 INDEXCH : CHAR; %LAUFVARIABLE FUER DAS FELD 'FIRSTNAME' ZUM AUSDRUCKEN\
22600 LISTPGNR: BOOLEAN; %TRUE IF THE SOURCE CONTAINS A PAGE MARK\
22700 ITEMLEN: INTEGER; %LENGTH OF A PRINTED LINENUMBER, 9 OR 12\
22800
22900
23000
23100 PROCEDURE WRTELINENR (SPACES : INTEGER);
23200
23300 VAR
23400 LINK : LINEPTRTY; %ZEIGER ZUM DURCHHANGELN DURCH DIE VERKETTUNG DER ZEILENNUMMERN\
23500 MAXCNT, %MAXIMUM ALLOWABLE VALUE OF COUNT\
23600 COUNT : INTEGER; %ZAEHLT DIE GEDRUCKTEN ZEILENNUMMERN PRO ZEILE\
23700 BEGIN %WRTELINENR\
23800 COUNT := 0;
23900 MAXCNT := (131 - SPACES) DIV ITEMLEN; %ITEMS ARE ITEMLEN CHARS EACH\
24000 LINK := LISTPTR↑.FIRST;
24100 REPEAT
24200 IF COUNT = MAXCNT THEN BEGIN
24300 WRITELN;
24400 WRITE (' ' : SPACES);
24500 COUNT := 0;
24600 END;
24700 COUNT := COUNT + 1;
24800 WRITE (LINK↑.LINENR * INCREMENT : 6);
24900 IF LISTPGNR THEN WRITE('/',LINK↑.PAGENR : 2);
25000 WRITE(' ');
25100 LINK := LINK↑.CONTLINK;
25200 UNTIL LINK = NIL;
25300 END %WRTELINENR\ ;
25400 BEGIN %PRINTLISTE\
25500 LISTPGNR := PAGECNT > 1;
25600 IF LISTPGNR THEN ITEMLEN := 12 ELSE ITEMLEN := 9;
25700 FIRSTPROC := NIL;
25800 LASTPROC := NIL;
25900 WITH FIRSTNAME ['M']↑ DO %DELETE 'MAIN'\ IF RLINK = NIL THEN FIRSTNAME ['M'] := LLINK ELSE BEGIN
26000 LISTPTR := RLINK;
26100 WHILE LISTPTR↑.LLINK # NIL DO LISTPTR := LISTPTR↑.LLINK;
26200 LISTPTR↑.LLINK := LLINK;
26300 FIRSTNAME ['M'] := RLINK;
26400 END;
26500 INDEXCH := 'A';
26600 WHILE (INDEXCH < 'Z') AND (FIRSTNAME [INDEXCH] = NIL) DO INDEXCH := SUCC (INDEXCH);
26700 IF FIRSTNAME [INDEXCH] # NIL THEN BEGIN
26800 PAGE;
26900 WRITELN ('CROSS REFERENCE LISTING OF IDENTIFIERS');
27000 WRITELN ('**************************************');
27100 FOR INDEXCH := INDEXCH TO 'Z' DO
27200 WHILE FIRSTNAME [INDEXCH] # NIL DO BEGIN
27300 LISTPTR := FIRSTNAME [INDEXCH];
27400 WHILE LISTPTR↑.LLINK # NIL DO BEGIN
27500 PRED := LISTPTR;
27600 LISTPTR := LISTPTR↑.LLINK;
27700 END;
27800 IF LISTPTR = FIRSTNAME [INDEXCH] THEN FIRSTNAME [INDEXCH] := LISTPTR↑.RLINK
27900 ELSE PRED↑.LLINK := LISTPTR↑.RLINK;
28000 %IS IT A PROCEDURE WHICH WAS CALLED AT LEAST ONCE?\
28100 IF LISTPTR↑.CALLED # NIL THEN BEGIN
28200 IF FIRSTPROC = NIL THEN BEGIN
28300 FIRSTPROC := LISTPTR;
28400 LASTPROC := FIRSTPROC;
28500 LASTPROC↑.CALLED↑.PROCNAME := NIL;
28600 END
28700 ELSE BEGIN
28800 LASTPROC↑.CALLED↑.PROCNAME := LISTPTR;
28900 LASTPROC := LISTPTR;
29000 END;
29100 END;
29200 WRITELN;
29300 WRITE (LISTPTR↑.NAME : 11);
29400 WRTELINENR (11);
29500 END;
29600 IF FIRSTPROC # NIL THEN BEGIN
29700 PAGE;
29800 WRITELN ('LISTING OF PROCEDURE AND FUNCTION CALLS');
29900 WRITELN ('***************************************');
30000 LASTPROC↑.CALLED↑.PROCNAME := NIL;
30100 LASTPROC := FIRSTPROC;
30200 WHILE LASTPROC # NIL DO BEGIN
30300 LISTPTR :=LASTPROC;
30400 WRITELN;WRITELN;
30500 WRITE (LASTPROC↑.NAME:11, ' IS CALLED BY :');
30600 WITH LASTPROC↑ DO REPEAT
30700 WRITELN;
30800 WRITE (' ' : 11,CALLEDBY↑.PROCNAME↑.NAME:11);
30900 LISTPTR↑.FIRST := CALLEDBY↑.FIRST;
31000 WRTELINENR (22);
31100 CALLEDBY := CALLEDBY↑.NEXTPROC;
31200 UNTIL CALLEDBY = NIL;
31300 WRITELN; WRITELN;
31400 IF LASTPROC↑.CALLED↑.NEXTPROC # NIL THEN BEGIN
31500 WRITE (' ' : 11, ' AND CALLS :');
31600 WITH LASTPROC↑.CALLED↑ DO REPEAT
31700 WRITELN;
31800 WRITE (' ' : 11,NEXTPROC↑.PROCNAME↑.NAME:11);
31900 LISTPTR↑.FIRST := NEXTPROC↑.FIRST;
32000 WRTELINENR (22);
32100 NEXTPROC := NEXTPROC↑.NEXTPROC;
32200 UNTIL NEXTPROC = NIL;
32300 END;
32400 LASTPROC := LASTPROC↑.CALLED↑.PROCNAME;
32500 END;
32600 PAGE;
32700 WRITELN ('NESTING OF PROCEDURES AND FUNCTIONS');
32800 WRITELN ('***********************************');
32900 PROCSTRUCL := PROCSTRUCF;
33000 REPEAT
33100 WRITELN;
33200 WITH PROCSTRUCL↑ DO BEGIN
33300 WRITE (' ':PROCLEVEL*3,PROCNAME↑.NAME : 11,LINENR * INCREMENT : 6);
33400 IF LISTPGNR THEN WRITE('/',PAGENR : 2)
33500 END;
33600 PROCSTRUCL := PROCSTRUCL↑.NEXTPROC;
33700 UNTIL PROCSTRUCL = NIL;
33800 END;
33900 END;
34000 END %PRINTLISTE\ ;
34100
34200
34300 PROCEDURE READFILENAME;
34400 %READS THE COMMAND LINE FOR CROSS\
34500 %THIS LINE HAS THE FORM 'OUTPUT FILE = INPUT FILE/LINE NUMBER INCREMENT'\
34600 %THE OUTPUT AND INPUT FILE SPECS CAN HAVE <PROT> AND [PROJ,PGMR] AND DEV: AS USUAL\
34700 %'/LINE NUMBER INCREMENT' MAY BE OMITTED -- DEFAULT IS 100.\
34800 %THE SWITCH /N CAUSES THE NEW FILE TO BE OUTPUT WITHOUT LINE NUMBERS\
34900
35000 VAR
35100 BAD: BOOLEAN;
35200 LEGALCHAR : SET OF CHAR; %MENGE DER LEGALEN EINGABEZEICHEN\
35300 MAXINDEX : INTEGER; %MAXIMALER INDEX FUER DIE FUELLUNG DES FELDES 'FILENAME'\
35400
35500
35600 FUNCTION READRADIX(RADIX:INTEGER):INTEGER;
35700
35800 VAR
35900 PPN : INTEGER; %HILFSVARIABLE\
36000 BEGIN %READRADIX\
36100 PPN := 0;
36200 CH := ' ';
36300 WHILE (CH = ' ') AND NOT EOLN(TTY) DO READ (TTY,CH);
36400 IF CH IN DIGITS THEN BEGIN
36500 PPN := ORD (CH) - ORD ('0');
36600 LOOP
36700 READ (TTY,CH);
36800 EXIT IF NOT (CH IN DIGITS);
36900 PPN := PPN * RADIX + ORD(CH) - ORD ('0');
37000 END;
37100 END;
37200 READRADIX := PPN;
37300 END %READRADIX\ ;
37400
37500
37600 FUNCTION INITIALS:INTEGER;
37700 VAR
37800 PPN,I:INTEGER;
37900 BEGIN
38000 PPN := 0;
38100 REPEAT
38200 READ(TTY,CH)
38300 UNTIL (CH # ' ') OR EOLN(TTY);
38400 IF CH IN LETTERS THEN BEGIN
38500 PPN := ORD(CH) - 60B;
38600 I := 1;
38700 LOOP
38800 READ(TTY,CH)
38900 EXIT IF NOT (CH IN LETTERS);
39000 IF I < 3 THEN PPN := PPN * 100B + ORD(CH) - 60B;
39100 I := I +1;
39200 END
39300 END;
39400 INITIALS:=PPN
39500 END %INITIALS\ ;
39600 BEGIN %READFILENAME\
39700 WITH INPUTFILE DO REPEAT
39800 BAD := FALSE;
39900 FILENAME := ' PAS';
40000 DEVICE := 'DSK ';
40100 PPN := 0;
40200 PROT := 0;
40300 OUTPUTFILE := INPUTFILE;
40400 I := 0;
40500 MAXINDEX := 6;
40600 CH := ' ';
40700 LEGALCHAR := ALPHANUM + ['.',':','[','<','/','=','←'];
40800 READ (TTY,CH);
40900 IF CH = '*' THEN READ (TTY,CH);
41000 LOOP
41100 WHILE (CH = ' ') AND NOT EOLN (TTY) DO READ (TTY,CH);
41200 EXIT IF (CH = ' ') OR BAD;
41300 IF CH IN LEGALCHAR
41400 THEN IF CH IN ALPHANUM THEN BEGIN
41500 LOOP
41600 I := I + 1;
41700 IF (I <= MAXINDEX) AND (CH IN ALPHANUM) THEN FILENAME [I] := CH;
41800 EXIT IF EOLN (TTY) OR NOT (CH IN ALPHANUM);
41900 READ (TTY,CH);
42000 END;
42100 IF CH IN ALPHANUM THEN CH := ' ';
42200 %TRASH OLD CHAR\
42300 LEGALCHAR := LEGALCHAR - ALPHANUM - ['>',']'];
42400 END
42500 ELSE CASE CH OF
42600 '.' :
42700 BEGIN
42800 FOR I := 7 TO 9 DO FILENAME [I] := ' ';
42900 I := 6;
43000 MAXINDEX := 9;
43100 CH := ' ';
43200 LEGALCHAR := LEGALCHAR + ALPHANUM - ['>',']',':','.'];
43300 END;
43400 ':' :
43500 BEGIN
43600 FOR I := 1 TO 6 DO DEVICE [I] := FILENAME [I];
43700 FILENAME := ' PAS';
43800 CH := ' ';
43900 LEGALCHAR := LEGALCHAR + ALPHANUM - ['>',']',':'];
44000 I := 0;
44100 END;
44200 '<' :
44300 BEGIN
44400 PROT := READRADIX(8);
44500 LEGALCHAR := LEGALCHAR + ['>'] - ['<',']',':'];
44600 END;
44700 '>' :
44800 BEGIN
44900 LEGALCHAR := LEGALCHAR - ['>'];
45000 CH := ' ';
45100 END;
45200 '[' :
45300 BEGIN
45400 PPN := READRADIX(10) * 1000000B;
45500 LEGALCHAR := LEGALCHAR + [']',','] - ['[','>',':'];
45600 END;
45700 ',' :
45800 BEGIN
45900 PPN := INITIALS + PPN;
46000 LEGALCHAR := LEGALCHAR - [','];
46100 END;
46200 ']' :
46300 BEGIN
46400 LEGALCHAR := LEGALCHAR - [']'];
46500 CH := ' ';
46600 END;
46700 '/' :
46800 BEGIN
46900 CASE TTY↑ OF
47000 '0','1','2','3','4','5','6','7','8',
47100 '9' : READ (TTY, INCREMENT);
47200 'I' :
47300 BEGIN
47400 REPEAT
47500 GET(TTY)
47600 UNTIL (TTY↑ IN ['0' .. '9']) OR EOLN(TTY);
47700 IF TTY↑ IN ['0'..'9'] THEN BEGIN
47800 READ(TTY,FEED);
47900 END
48000 END;
48100 'F':
48200 BEGIN
48300 FAST := TRUE;
48400 GET(TTY);
48500 END;
48600 'N' :
48700 BEGIN
48800 SEQUENCE := FALSE; GET(TTY)
48900 END
49000 END;
49100 CH := ' '; %THIS CAUSES A NEW CH TO BE READ\
49200 END;
49300 '=',
49400 '←' :
49500 BEGIN
49600 OUTPUTFILE := INPUTFILE;
49700 FILENAME := ' PAS';
49800 DEVICE := 'DSK ';
49900 PPN := 0;
50000 MAXINDEX := 6;
50100 PROT := 0;
50200 I := 0;
50300 CH := ' ';
50400 LEGALCHAR := LEGALCHAR +
50500 ALPHANUM + ['.',':','[','<']- ['=','←'];
50600 END
50700 END
50800 ELSE BEGIN
50900 WRITELN (TTY, 'INVALID INPUT ''', CH, '''');
51000 WRITE(TTY, '*');
51100 BAD := TRUE;
51200 BREAK;
51300 READLN(TTY);
51400 END;
51500 END %LOOP\;
51600 UNTIL (CH # '*') AND NOT BAD;
51700 IF INPUTFILE.FILENAME = ' PAS' THEN INPUTFILE := OUTPUTFILE;
51800 WITH OUTPUTFILE DO IF FILENAME = ' PAS' THEN BEGIN
51900 FILENAME := INPUTFILE.FILENAME;
52000 FILENAME [7] := 'N';
52100 FILENAME [8] := 'E';
52200 FILENAME [9] := 'W';
52300 END;
52400 END %READFILENAME\ ;
52500
52600 BEGIN %MAIN\
52700 INIT;
52800 WITH INPUTFILE DO
52900 LOOP
53000 READFILENAME;
53100 RESET (INPUT,FILENAME,PROT,PPN,DEVICE);
53200 EXIT IF NOT EOF (INPUT);
53300 WRITELN (TTY);
53400 WRITE (TTY,DEVICE,':',FILENAME : 6,'.',FILENAME [7],FILENAME [8],FILENAME [9]);
53500 IF PPN # 0 THEN BEGIN
53600 WRITE(TTY,' [',PPN DIV 1000000B:6,',');
53700 WRITE(TTY,CHR(PPN DIV 10000B MOD 100B + 60B));
53800 WRITE(TTY,CHR(PPN DIV 100B MOD 100B +60B));
53900 WRITE(TTY,CHR(PPN MOD 100B + 60B),']')
54000 END;
54100 WRITELN (TTY,' NOT FOUND');
54200 WRITE(TTY, '*');
54300 BREAK(TTY);
54400 END;
54500 WRITELN (TTY);
54600 WRITELN (TTY,VERSION);
54700 WRITELN (TTY);
54800 BREAK;
54900 %FIND MAX POSSIBLE LINE NO WITH THIS INCREMENT, LEAVING 1 FOR SOS BUG\
55000 MAXINC := (99999 DIV INCREMENT) - 1;
55100 %WE HAVE ONLY 13 BITS (0..8191) FOR THE LINE COUNTER\
55200 IF MAXINC > 8000 THEN MAXINC := 8000;
55300 WITH OUTPUTFILE DO BEGIN
55400 REWRITE (NEWFIL,FILENAME);
55500 FILENAME[7]:='L'; FILENAME[8]:='S'; FILENAME[9]:='T';
55600 IF FAST THEN REWRITE(OUTPUT, FILENAME, 0, 0, 'NUL ')
55700 ELSE REWRITE (OUTPUT, FILENAME);
55800 END;
55900 CH := ' ';
56000 DATUM;
56100 HEADER;
56200 BLOCK;
56300 WRTELINE (BUFFLEN+2);
56400 IF ERRFLAG THEN WRITE(TTY, '? ') ELSE WRITE (TTY,'NO ');
56500 WRITELN (TTY,MESSAGE);
56600 IF FAST THEN REWRITE(OUTPUT, OUTPUTFILE.FILENAME, 0, 0, 'DSK ');
56700 PRINTLISTE;
56800 END %CROSS\.